home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CICA 1993 April
/
CICA MS Windows - April 1993.iso
/
unzipped
/
programr
/
tp
/
coldem
/
coldem.pas
next >
Wrap
Pascal/Delphi Source File
|
1992-06-29
|
7KB
|
189 lines
{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Demo program }
{ Copyright (c) 1991 by Borland International }
{ Changes for demonstration of ChooseColor }
{ and ChooseFont are made by Martin H. Speiser }
{ }
{************************************************}
{ "ColDem" Windows application written in Turbo Pascal }
program ColDem;
{$R COLDEM}
uses WinTypes, WinProcs, Strings, Win31, CommDlg;
const
AppName = 'ColDem';
const
idm_Color = 100;
idm_Font = 102;
idm_About = 101;
idd_StaticControl = 1040;
idd_EditControl = 1041;
function About(Dialog: HWnd; Message, WParam: Word;
LParam: Longint): Bool; export;
begin
About := True;
case Message of
wm_InitDialog:
Exit;
wm_Command:
if (WParam = id_Ok) or (WParam = id_Cancel) then
begin
EndDialog(Dialog, 1);
Exit;
end;
end;
About := False;
end;
function ColorHookProc(HDialog: HWnd; Message, WParam: Word;
LParam: Longint): Bool; export;
begin
ColorHookProc := True;
case Message of
wm_InitDialog : begin
SetWindowText(GetDlgItem(HDialog,idd_EditControl),PChar(PChooseColor(LParam)^.lCustData));
SendMessage(GetDlgItem(HDialog,idd_EditControl),em_LimitText,30,0);
{SetFocus(GetDlgItem(HDialog,idd_EditControl));}
exit;
end
end;
ColorHookProc := False;
end;
function WindowProc(Window: HWnd; Message, WParam: Word;
LParam: Longint): Longint; export;
var AboutProc : TFarProc;
hDisplay : HDC;
ps : TPaintStruct;
rc : TRect;
cc : TChooseColor;
cf : TChooseFont;
lf : TLogFont;
CustCol : array[0..15] of longint;
HookProc : TFarProc;
szText : array[0..30] of char;
lpszText : PChar;
begin
WindowProc := 0;
case Message of
wm_Command : case WParam of
idm_Color : begin
lpszText := @szText;
StrPCopy(lpszText,'Hello World');
HookProc := MakeProcInstance(@ColorHookProc,HInstance);
cc.lStructSize := SizeOf(cc);
{ Size of Record, for possible extensions in the future }
cc.hWndOwner := Window;
{ Handle of Parent }
cc.hInstance := HInstance;
{ Instance handle, only necessary for template }
cc.rgbResult := RGB(255,255,255);
{ Default color at input, choosen color on exit }
cc.lpCustColors := @CustCol;
{ Definition of custom colors at exit }
cc.Flags := cc_RGBInit or
cc_EnableHook or
cc_EnableTemplate;
{ see COMMDLG.PAS for possible values }
cc.lCustData := Longint(lpszText);
{ Pointer to custom data for hook function }
cc.lpfnHook := HookProc;
{ Pointer to hook function }
cc.lpTemplateName := 'ChooseColor';
{ Name of Template }
ChooseColor(cc);
FreeProcInstance(HookProc);
end;
idm_Font : begin
cf.lStructSize := SizeOf(cf);
{ Size of Record, purpose see above }
cf.hwndOwner := Window;
cf.lpLogFont := @lf;
{ Handle of parent window }
cf.Flags := cf_Effects or
cf_ScreenFonts or
cf_TTOnly or
cf_EnableTemplate;
{ see COMMDLG.PAS for possible values }
cf.rgbColors := RGB(0,0,0);
{ Default color at input, choosen color on exit }
cf.lpTemplateName := 'FontDialog';
cf.hInstance := HInstance;
cf.nFontType := TrueType_Fonttype;
ChooseFont(cf);
end;
idm_About : begin
AboutProc := MakeProcInstance(@About, HInstance);
DialogBox(HInstance, 'AboutBox', Window, AboutProc);
FreeProcInstance(AboutProc);
Exit;
end;
end;
wm_Destroy : begin
PostQuitMessage(0);
Exit;
end;
end;
WindowProc := DefWindowProc(Window, Message, WParam, LParam);
end;
procedure WinMain;
var
Window: HWnd;
Message: TMsg;
const
WindowClass: TWndClass = (
style: 0;
lpfnWndProc: @WindowProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: AppName;
lpszClassName: AppName);
begin
if HPrevInst = 0 then
begin
WindowClass.hInstance := HInstance;
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(white_Brush);
if not RegisterClass(WindowClass) then Halt(255);
end;
Window := CreateWindow(
AppName,
'Turbo Pascal ChooseColor Demo',
ws_OverlappedWindow,
cw_UseDefault,
cw_UseDefault,
cw_UseDefault,
cw_UseDefault,
0,
0,
HInstance,
nil);
ShowWindow(Window, CmdShow);
UpdateWindow(Window);
while GetMessage(Message, 0, 0, 0) do
begin
TranslateMessage(Message);
DispatchMessage(Message);
end;
Halt(Message.wParam);
end;
begin
WinMain;
end.